home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / mrgsort.arc / TXTFILES.PAS < prev    next >
Pascal/Delphi Source File  |  1990-04-18  |  23KB  |  673 lines

  1. {$IFDEF ver50}
  2. {$A-,B-,D-,E+,F-,I+,L-,N-,O-,R-,S+,V+}  (* MUST REMOVE FOR TP4 *)
  3. {$ELSE}
  4. {$R-,S-,I+,D-,T+,F-,V+,B-,N-,L+ }
  5. {$ENDIF}
  6.  
  7. UNIT txtfiles;
  8. (* Kluges to replace missing STANDARD constructs in Turbo  *)
  9. (* Unfortunately these routines cannot be overloaded, as   *)
  10. (* are the standard procedures, and must also be referred  *)
  11. (* to by new (but similar) names.  A proper system imple-  *)
  12. (* mentation would avoid these nuisances.                  *)
  13.  
  14. (* With this module in place text input can be programmed  *)
  15. (* with STANDARD Pascal semantics.  The resultant source   *)
  16. (* is then portable to any ISO standard system with a      *)
  17. (* minimum of fuss.  It is bad enough to have to alter std *)
  18. (* procedure names, but absolutely impossible to have to   *)
  19. (* rethink the entire i/o process.                         *)
  20.  
  21. (* Note that "exists" and "readx" are inserted underneath  *)
  22. (* the standard implementations of "reset" and "read".     *)
  23. (* These extensions are not normally available in ISO std. *)
  24.  
  25. (* 1.20 Added filename, page, prompt, overprint.           *)
  26. (* 1.10 Added stdin, stdout, stderr, blockdev to report    *)
  27. (*      on any redirection imposed or general destination  *)
  28.  
  29. (* Copyright (c) 1988 by C.B. Falconer,                    *)
  30. (*                       680 Hartford Tpk.,                *)
  31. (*                       Hamden, Ct 06517   (203) 281-1438 *)
  32. (* All rights reserved.                                    *)
  33.  
  34. (* This is NOT free software, but SHAREWARE.  If you use   *)
  35. (* this after a suitable test period (1 month suggested)   *)
  36. (* you must register it, for a fee of $20.  This will      *)
  37. (* entitle you to a reasonable amount of telephone advice  *)
  38. (* (on your paid call) and future upgrades and support.    *)
  39. (* I will also supply registered owners with the source so *)
  40. (* that they can recompile for 80x87 processors.           *)
  41.  
  42. (* The compiled TPU supplied was compiled under Turbo      *)
  43. (* Pascal  4, without using any numeric processor.  Thus   *)
  44. (* it is incompatible with programs using the 80x87.       *)
  45.  
  46. (* This module functions with Turbo Pascal 4.0.            *)
  47. (* No warranty whatsover is made, and C.B. Falconer will   *)
  48. (* not be liable for any damages or failures.              *)
  49.  
  50. (* If you use this module with the CRT unit, the EOF char  *)
  51. (* (CTL-Z) will never appear, UNLESS your program does     *)
  52. (*       checkeof := true;     somewhere before using this *)
  53.  
  54. (* A note on naming:                                       *)
  55. (* All replacement read procedures are either READ???? or  *)
  56. (* READX??? functions.  The read procedures abort the      *)
  57. (* program on invalid input, while the readx functions     *)
  58. (* return TRUE for any error.  The ??? is  INT, WD, LONG   *)
  59. (* or REAL, depending on the input type desired.           *)
  60.  
  61. INTERFACE
  62.  
  63. USES dos;
  64.  
  65.   TYPE
  66.     fntype      = string[80];   (* holds a complete file name *)
  67.  
  68.   (* 1---------------1 *)
  69.  
  70.   FUNCTION existxt(VAR f : text) : boolean;
  71.   (* Exists is a standard feature of PascalP.             *)
  72.  
  73.   (* 1---------------1 *)
  74.  
  75.   PROCEDURE get(VAR f : text);
  76.   (* since Turbo never supplied it, we can use the original name *)
  77.  
  78.   (* 1---------------1 *)
  79.  
  80.   PROCEDURE filename(VAR f : text; VAR fn : fntype);
  81.   (* Highly Turbo specific.  This allows other procedures/functions *)
  82.   (* to extract the filename when passed only the actual file. You  *)
  83.   (* thus do not need to retain a user supplied name elsewhere.     *)
  84.   (* THIS IS NOT A FUNCTION - thus can be ported to Std. Systems.   *)
  85.  
  86.   (* 1---------------1 *)
  87.  
  88.   PROCEDURE page(VAR f : text);   (* Missing in Turbo *)
  89.  
  90.   (* 1---------------1 *)
  91.  
  92.   PROCEDURE overprint(VAR f : text);
  93.   (* Next line overprints this one.  Use like "writeln"  *)
  94.  
  95.   (* 1---------------1 *)
  96.  
  97.   PROCEDURE prompt(VAR f : text);
  98.   (* Forces buffer flushing without eoln.  Null in Turbo. *)
  99.   (* For logical equivalence with output buffered systems *)
  100.   (* If your source uses this whenever prompting the user *)
  101.   (* the code will be portable to other Pascal systems.   *)
  102.   (* e.g "write(Enter your name:); prompt(output);"       *)
  103.  
  104.   (* 1---------------1 *)
  105.  
  106.   FUNCTION version(show : boolean) : integer;
  107.   (* returns the version number.  Show causes a console message *)
  108.  
  109.   (* 1---------------1 *)
  110.  
  111.   FUNCTION fptr(VAR f : text) : char;
  112.   (* Allows replacing the STANDARD construct f^ by "fptr(f)"    *)
  113.   (* A proper system implementation actually returns a pointer  *)
  114.   (* so that "f^ := char" is possible.  Not allowed here.       *)
  115.  
  116.   (* 1---------------1 *)
  117.  
  118.   PROCEDURE skipblks(VAR f : text);
  119.   (* Skips blanks, but NOT eolns until first non-blank char     *)
  120.   (* A tab is considerd a blank.  Must be separated due to the  *)
  121.   (* non-standard Turbo eoln implementation.                    *)
  122.  
  123.   (* 1---------------1 *)
  124.  
  125.   PROCEDURE skipwhite(VAR f : text);
  126.   (* skips blanks and eolns until first non-blank char          *)
  127.   (* This hides the lack of f^ = ' ' in Turbo when eoln is true *)
  128.  
  129.   (* 1---------------1 *)
  130.  
  131.   FUNCTION readxwd(VAR f : text; VAR w : word) : boolean;
  132.   (* returns true for input error, when fptr(f) is bad char *)
  133.   (* Replacement for standard read(word) with error checks. *)
  134.   (* Unlike Turbo, reading terminates on the 1st non digit, *)
  135.   (* but only after leading blanks have been skipped.       *)
  136.   (* A feature of PascalP for reals/integers/words (readx). *)
  137.   (* Note that, apart from the non-standard Std procedure   *)
  138.   (* nomenclature, this is written entirely in STD Pascal.  *)
  139.   (* On exit fptr(f) will return the terminating character  *)
  140.   (* On overflow input is scanned to a non-numeric char.    *)
  141.  
  142.   (* 1---------------1 *)
  143.  
  144.   FUNCTION readxint(VAR f : text; VAR i : integer) : boolean;
  145.   (* returns true for input error, when fptr(f) is bad char *)
  146.   (* Replacement for standard read(integer) with error chks *)
  147.   (* Unlike Turbo, reading terminates on the 1st non digit, *)
  148.   (* but only after leading blanks and (optional) sign have *)
  149.   (* been skipped.  A feature of PascalP for reals/integers *)
  150.   (* Note that, apart from the non-standard Std procedure   *)
  151.   (* nomenclature, this is written entirely in STD Pascal.  *)
  152.   (* On exit fptr(f) will return the terminating character  *)
  153.   (* On overflow input is scanned to a non-numeric char.    *)
  154.  
  155.   (* 1---------------1 *)
  156.  
  157.   PROCEDURE readint(VAR f : text; VAR i : integer);
  158.   (* replacement for STANDARD Pascal read(f, integer), which is *)
  159.   (* defined to cause a system error and halt on invalid input. *)
  160.   (* Unlike Turbo, reading terminates on the 1st non digit, but *)
  161.   (* only after leading blanks and (optional) sign have been    *)
  162.   (* skipped. Again, written in STD Pascal.                     *)
  163.   (* On exit fptr(f) will return the terminating character.     *)
  164.   (* On overflow input is scanned to a non-numeric character.   *)
  165.  
  166.   (* 1---------------1 *)
  167.  
  168.   PROCEDURE readwd(VAR f : text; VAR w : word);
  169.   (* This does not exist in STANDARD Pascal (only integer), but *)
  170.   (* this is how it would look if it did.  This is defined to   *)
  171.   (* cause a system error and halt on invalid input.            *)
  172.   (* Unlike Turbo, reading terminates on the 1st non digit, but *)
  173.   (* only after leading blanks and (optional) sign have been    *)
  174.   (* skipped. Again, written in STD Pascal.                     *)
  175.   (* On exit fptr(f) will return the terminating character.     *)
  176.   (* On overflow input is scanned to a non-numeric character.   *)
  177.  
  178.   (* 1---------------1 *)
  179.  
  180.   FUNCTION readxlong(VAR f : text; VAR l : longint) : boolean;
  181.   (* Just like readxint, but for longints.  Always signed. *)
  182.  
  183.   (* 1---------------1 *)
  184.  
  185.   FUNCTION readxreal(VAR f : text; VAR r : real) : boolean;
  186.   (* Again, like readxint, but for reals. Also see readreal below *)
  187.  
  188.   (* 1---------------1 *)
  189.  
  190.   PROCEDURE readreal(VAR f : text; VAR r : real);
  191.   (* Replacement for the standard read(f, r : real), which aborts *)
  192.   (* on bad entries.  As in STD Pascal, the real is terminated by *)
  193.   (* the first character which cannot be a part of the value, and *)
  194.   (* fptr(f) accesses that terminating character.  Note that this *)
  195.   (* can accept an unlimited length string of digits, eg leading  *)
  196.   (* zeroes, and trailing zeroes after the decimal pt, none of    *)
  197.   (* which really affect the value.  Leading blanks and eolns are *)
  198.   (* skipped. Action on real over/underflow depends on the system *)
  199.  
  200.   (* 1---------------1 *)
  201.  
  202.   FUNCTION blockdev(VAR f : text) : boolean;
  203.   (* Is the file attached to a disk file *)
  204.  
  205.   (* 1---------------1 *)
  206.  
  207.   FUNCTION stdin(VAR f : text) : boolean;
  208.   (* Is the file attached to the console device for input *)
  209.  
  210.   (* 1---------------1 *)
  211.  
  212.   FUNCTION stdout(VAR f : text) : boolean;
  213.   (* is the file attached to the console device for output *)
  214.  
  215.   (* 1---------------1 *)
  216.  
  217.   FUNCTION stderr(VAR f : text) : boolean;
  218.   (* is the file attached to the monitor for output *)
  219.  
  220. IMPLEMENTATION
  221.  
  222.   CONST        (* really initialized variables *)
  223.     digs       : SET OF char  = ['0'..'9'];
  224.     signs      : SET OF char  = ['+', '-'];
  225.     errornum   : integer      = 0;
  226.     errorat    : pointer      = NIL;
  227.     saverrproc : pointer      = NIL;
  228.  
  229.     ver                       = 120;
  230.     copyrite                  = ' Copyright (c) 1988 by C.B. Falconer';
  231.     chrdev                    = $80;  (* 0 bit implies file (block) device *)
  232.     istdin                    = $01;
  233.     istdout                   = $02;
  234.     istderr                   = $04;
  235.  
  236.   (* 1---------------1 *)
  237.  
  238.   FUNCTION version(show : boolean) : integer;
  239.   (* returns the version number.  Show causes a console message *)
  240.  
  241.     BEGIN (* version *)
  242.     version := ver;
  243.     IF show THEN BEGIN
  244.       write('TXTFILES module Version ', ver DIV 100 : 1, '.');
  245.       IF ver MOD 100 < 10 THEN write('0');
  246.       writeln(ver MOD 100, '.', copyrite); END;
  247.     END; (* version *)
  248.  
  249.   (* 1---------------1 *)
  250.  
  251.   FUNCTION existxt(VAR f : text) : boolean;
  252.  
  253.     BEGIN (* existxt *)
  254. {$i-}
  255.     reset(f); {$i+}
  256.     existxt := ioresult = 0;
  257.     END; (* existxt *)
  258.  
  259.   (* 1---------------1 *)
  260.  
  261.   PROCEDURE filename(VAR f : text; VAR fn : fntype);
  262.   (* Highly Turbo specific *)
  263.  
  264.     TYPE
  265.       textbuf    = ARRAY[0..127] OF char;
  266.  
  267.       textrec    = RECORD
  268.         handle     : word;          (* MSDOS file handle *)
  269.         mode       : word;          (* 0=read, 1=write, 2=rdwrt *)
  270.         bufsize    : word;          (* of textbuf *)
  271.         private    : word;
  272.         bufpos     : word;          (* next char pointer *)
  273.         bufend     : word;          (* size of buffer valide *)
  274.         bufptr     : ^textbuf;      (* location, may not be buffer below *)
  275.         openfunc   : pointer;       (* pointers to routines, normally *)
  276.         inoutfunc  : pointer;       (*    in system unit, but may not be *)
  277.         flushfunc  : pointer;
  278.         closefunc  : pointer;
  279.  
  280.         (* reuse the userdata field for ISO std i/o semantics (plan) *)
  281.         getpends   : boolean;       (* assumed initialized to false *)
  282.         eolnflag   : boolean;       (* so we can have fchar = ' ' *)
  283.         eoflag     : boolean;       (* delay so final get functions *)
  284.         fchar      : char;
  285.  
  286.         userdata   : ARRAY[5..16] OF byte; (* available *)
  287.         name       : ARRAY[0..79] OF char;
  288.         buffer     : textbuf;
  289.         END; (* textrec *)
  290.  
  291.     VAR
  292.       i      : integer;
  293.  
  294.     BEGIN (* filename *)
  295.     fn := ''; i := 0;
  296.     WHILE (i < 79) AND (textrec(f).name[i] <> chr(0)) DO BEGIN
  297.       fn := concat(fn, textrec(f).name[i]); i := succ(i); END;
  298.     END; (* filename *)
  299.  
  300.   (* 1---------------1 *)
  301.  
  302.   PROCEDURE page(VAR f : text);   (* Missing in Turbo *)
  303.  
  304.     BEGIN (* page *)
  305.     write(f, chr(12));
  306.     END; (* page *)
  307.  
  308.   (* 1---------------1 *)
  309.  
  310.   PROCEDURE overprint(VAR f : text);
  311.   (* Next line overprints this one *)
  312.  
  313.     BEGIN (* overprint *)
  314.     write(f, chr(13));
  315.     END; (* overprint *)
  316.  
  317.   (* 1---------------1 *)
  318.  
  319.   PROCEDURE prompt(VAR f : text);
  320.   (* forces buffer flushing without eoln *)
  321.  
  322.     BEGIN (* prompt *)
  323.     END; (* prompt *)
  324.  
  325.   (* 1---------------1 *)
  326.  
  327.   PROCEDURE get(VAR f : text);
  328.   (* Together with fptr below, implements the ISO/ANSI semantics  *)
  329.  
  330.     VAR
  331.       junk     : char;
  332.  
  333.     BEGIN (* get *)
  334.     read(f, junk);     (* discarding the old value of fptr *)
  335.     END; (* get *)
  336.  
  337.   (* 1---------------1 *)
  338.  
  339.   FUNCTION fptr(VAR f : text) : char;
  340.   (* A replacement for the ISO/ANSI Standard Pascal operation f^   *)
  341.   (* With this it is possible to build well behaved input routines *)
  342.   (* to convert text to integers, reals, etc. and avoid crashies   *)
  343.   (* on erroneous user input.  The standard usage of f^ = ' ' at   *)
  344.   (* EOF is not implemented, because of Turbos internal operation. *)
  345.  
  346.     CONST
  347.       eofmark   = 26;     (* 01ah = CTL-Z *)
  348.  
  349.     (* 2---------------2 *)
  350.  
  351.     FUNCTION fptrc(VAR f : text) : char;
  352.     (* For this to function, on a text file, you MUST call eof(f) *)
  353.     (* first, which ensures the char is present in the internal   *)
  354.     (* file buffer.  This procedure extracts it.                  *)
  355.  
  356.       inline(
  357.         $5f/                   {pop  di;              ^file (off)  }
  358.         $07/                   {pop  es                     (seg)  }
  359.         $26/ $8B/ $5D/ $08/    {mov  bx,es:[di+8];    buffer index }
  360.         $26/ $C4/ $7D/ $0C/    {les  di,es:[di+0ch];  ^buffer      }
  361.         $26/ $8A/ $01);        {mov  al,es:[bx+di];   get char     }
  362.  
  363.     (* 2---------------2 *)
  364.  
  365.     BEGIN (* fptr *)
  366. {$i-}
  367.     IF eof(f) {$i+} THEN fptr := chr(eofmark)
  368.     ELSE IF ioresult <> 0 THEN fptr := chr(eofmark)
  369.     ELSE fptr := fptrc(f);
  370.     END; (* fptr *)
  371.  
  372.   (* 1---------------1 *)
  373.  
  374.   PROCEDURE skipblks(VAR f : text);
  375.  
  376.     VAR
  377.       ch    : char;
  378.  
  379.     BEGIN (* skipblks *)
  380.     ch := fptr(f);
  381.     WHILE (ch = ' ') OR (ch = chr(9)) DO BEGIN
  382.       get(f); ch := fptr(f); END;
  383.     END; (* skipblks *)
  384.  
  385.   (* 1---------------1 *)
  386.  
  387.   PROCEDURE skipwhite(VAR f : text);
  388.  
  389.     BEGIN (* skipwhite *)
  390.     REPEAT             (* caution - Turbo returns eoln at eof *)
  391.       IF eoln(f) AND NOT eof(f) THEN readln(f);
  392.       skipblks(f);
  393.     UNTIL eof(f) OR NOT eoln(f);
  394.     END; (* skipwhite *)
  395.  
  396.   (* 1---------------1 *)
  397.  
  398.   FUNCTION readxwd(VAR f : text; VAR w : word) : boolean;
  399.  
  400.     VAR
  401.       value,
  402.       digit      : word;
  403.  
  404.     BEGIN (* readxwd *)
  405.     digs := ['0'..'9'];
  406.     readxwd := true; w := 0; value := 0;            (* default error *)
  407.     skipwhite(f);
  408.     IF NOT eof(f) THEN BEGIN
  409.       IF fptr(f) IN digs THEN readxwd := false;       (* found value *)
  410.       WHILE fptr(f) IN digs DO BEGIN
  411.         digit := ord(fptr(f)) - ord('0');
  412.         IF (value < 6553) OR ((value = 6553) AND (digit < 6)) THEN
  413.           value := 10 * value + digit
  414.         ELSE readxwd := true;                            (* overflow *)
  415.         get(f); END;
  416.       w := value; END;
  417.     END; (* readxwd *)
  418.  
  419.   (* 1---------------1 *)
  420.  
  421.   FUNCTION readxint(VAR f : text; VAR i : integer) : boolean;
  422.  
  423.     VAR
  424.       negative   : boolean;
  425.       value      : word;
  426.  
  427.     BEGIN (* readxint *)
  428.     readxint := true; i := 0; negative := false;    (* default error *)
  429.     skipwhite(f);
  430.     IF NOT eof(f) THEN BEGIN
  431.       value := 0; negative := false;
  432.       IF fptr(f) IN signs THEN BEGIN            (* absorbing any '+' *)
  433.         negative := fptr(f) = '-'; get(f); END;
  434.       IF fptr(f) IN digs THEN                         (* found value *)
  435.         readxint := readxwd(f, value);
  436.       IF negative AND (value <= 32768) THEN i := -value
  437.       ELSE IF value <= 32767 THEN i := value
  438.       ELSE readxint := true; END;                        (* overflow *)
  439.     END; (* readxint *)
  440.  
  441.   (* 1---------------1 *)
  442.  
  443.   FUNCTION callersaddr : pointer;
  444.   (* relies on the fact that bp always points to the return addr *)
  445.   (* and that this is a FAR return, i.e. via an entry to a unit. *)
  446.  
  447.     inline(
  448.       $C4/ $46/ $02/   {les ax,[bp+2]                   }
  449.       $8C/ $C2);       {mov dx,es;  now dx:ax is address}
  450.  
  451.   (* 1---------------1 *)
  452.  
  453.   PROCEDURE readint(VAR f : text; VAR i : integer);
  454.  
  455.     BEGIN (* readint *)
  456.     IF readxint(f, i) THEN BEGIN     (* invalid numeric format error *)
  457.       errorat := callersaddr; errornum := 106;
  458.       halt(errornum); END;
  459.     END; (* readint *)
  460.  
  461.   (* 1---------------1 *)
  462.  
  463.   PROCEDURE readwd(VAR f : text; VAR w : word);
  464.  
  465.     BEGIN (* readwd *)
  466.     IF readxwd(f, w) THEN BEGIN (* invalid numeric format error *)
  467.       errorat := callersaddr; errornum := 106;
  468.       halt(errornum); END;
  469.     END; (* readwd *)
  470.  
  471.   (* 1---------------1 *)
  472.  
  473.   FUNCTION readxlong(VAR f : text; VAR l : longint) : boolean;
  474.  
  475.     CONST
  476.       threshold  = 214748363;
  477.  
  478.     VAR
  479.       negative   : boolean;
  480.       digit      : integer;
  481.       value      : longint;
  482.  
  483.     BEGIN (* readxlong *)
  484.     readxlong := true; l := 0; negative := false;   (* default error *)
  485.     skipwhite(f);
  486.     IF NOT eof(f) THEN BEGIN
  487.       value := 0; negative := false;
  488.       IF fptr(f) IN signs THEN BEGIN            (* absorbing any '+' *)
  489.         negative := fptr(f) = '-'; get(f); END;
  490.       IF fptr(f) IN digs THEN BEGIN                   (* found value *)
  491.         readxlong := false;              (* no error unless overflow *)
  492.         WHILE fptr(f) IN digs DO BEGIN
  493.           digit := ord(fptr(f)) - ord('0');
  494.           IF value <= threshold THEN value := value * 10 + digit
  495.           ELSE readxlong := true;                        (* overflow *)
  496.           get(f); END;
  497.         IF negative THEN l := -value
  498.         ELSE l := value; END;
  499.       END;
  500.     END; (* readxlong *)
  501.  
  502.   (* 1---------------1 *)
  503.  
  504.   FUNCTION readxreal(VAR f : text; VAR r : real) : boolean;
  505.   (* true for error *)
  506.  
  507.     LABEL 10;          (* error exit *)
  508.  
  509.     VAR
  510.       maxsig,
  511.       significand    : longint;
  512.       exponent       : integer;
  513.       decpt          : integer;
  514.       havedigit,
  515.       minus          : boolean;
  516.  
  517.     BEGIN (* readxreal *)
  518.     minus := false; r := 0.0; readxreal := true; havedigit := false;
  519.     significand := 0; decpt := 0; exponent := 0;        (* defaults *)
  520.     maxsig := $7ffffff5 DIV 10;       (* before nextch can overflow *)
  521.     skipwhite(f);
  522.     IF fptr(f) IN signs THEN BEGIN
  523.       minus := fptr(f) = '-'; get(f); END;
  524.     IF fptr(f) IN digs + ['.'] THEN BEGIN
  525.       readxreal := false;          (* should be able to get a value *)
  526.       WHILE (fptr(f) IN digs) AND (significand < maxsig) DO BEGIN
  527.         significand := significand * 10 + (ord(fptr(f)) - ord('0'));
  528.         havedigit := true; get(f); END;
  529.       WHILE fptr(f) IN digs DO BEGIN         (* gobble non-significants *)
  530.         decpt := succ(decpt); get(f); END;
  531.       IF fptr(f) = '.' THEN BEGIN
  532.         get(f);
  533.         IF NOT (havedigit OR (fptr(f) IN digs)) THEN BEGIN
  534.           readxreal := true; GOTO 10; END
  535.         ELSE BEGIN
  536.           WHILE (fptr(f) IN digs) AND (significand < maxsig) DO BEGIN
  537.             significand := significand * 10 + (ord(fptr(f)) - ord('0'));
  538.             decpt := pred(decpt); get(f); END;
  539.           WHILE fptr(f) IN digs DO get(f); END; (* eat non-significants *)
  540.         END;
  541.  
  542.       (* now have to worry about E+-nn appended *)
  543.       IF fptr(f) IN ['E', 'e'] THEN BEGIN
  544.         get(f);
  545.         IF NOT (fptr(f) IN digs + signs) THEN BEGIN
  546.           readxreal := true; GOTO 10; END
  547.         ELSE IF readxint(f, exponent) THEN BEGIN
  548.           readxreal := true; GOTO 10; END;
  549.         END;
  550.  
  551.       (* Now we have valid significand, decpt, exponent *)
  552.       exponent := exponent + decpt;
  553.       r := significand;
  554.       WHILE exponent > 0 DO BEGIN
  555.         r := 10.0 * r; exponent := pred(exponent); END;
  556.       WHILE exponent < 0 DO BEGIN
  557.         r := r / 10.0; exponent := succ(exponent); END;
  558.       IF minus THEN r := -r; END;
  559. 10: END; (* readxreal *)
  560.  
  561.   (* 1---------------1 *)
  562.  
  563.   PROCEDURE readreal(VAR f : text; VAR r : real);
  564.  
  565.     BEGIN (* readreal *)
  566.     IF readxreal(f, r) THEN BEGIN  (* invalid numeric format error *)
  567.       errorat := callersaddr; errornum := 106;
  568.       halt(errornum); END;
  569.     END; (* readreal *)
  570.  
  571.   (* 1---------------1 *)
  572. {$F+}
  573.   PROCEDURE txterrproc;      (* MUST be a FAR procedure *)
  574.  
  575.     VAR
  576.       errorptr  : RECORD
  577.         offset    : integer;
  578.         segment   : integer;
  579.         END                    ABSOLUTE errorat;
  580.  
  581.     BEGIN (* txterrproc *)
  582.     exitproc := saverrproc;
  583.     IF errornum <> 0 THEN BEGIN
  584.       exitcode := errornum;
  585.       writeln('Invalid numerical entry or overflow ');
  586.       errorptr.segment := errorptr.segment - prefixseg - 16;
  587.       erroraddr := errorat; END;
  588.     END; (* txterrproc *)
  589.  
  590.   (* 1---------------1 *)
  591.  
  592.   FUNCTION qfstatus(VAR f; VAR s : integer) : boolean;
  593.   (* returns false if file not open or open for random access *)
  594.  
  595.     VAR
  596.       ff     : text ABSOLUTE f;
  597.       regs   : registers;
  598.  
  599.     BEGIN (* qfstatus *)
  600.     qfstatus := false;            (* default *)
  601.     WITH regs, textrec(ff) DO
  602.       IF (mode = fminput) OR (mode = fmoutput) OR (mode = fminout) THEN BEGIN
  603.         ax := $4400; bx := handle;
  604.         msdos(regs);                     (* get device info *)
  605.         IF (flags AND fcarry) = 0 THEN BEGIN
  606.           qfstatus := true; s := integer(dx); END;
  607.         END;
  608.     END; (* qfstatus *)
  609.  
  610.   (* 1---------------1 *)
  611.  
  612.   FUNCTION blockdev(VAR f : text) : boolean;
  613.   (* Is the file attached to a disk file *)
  614.  
  615.     VAR
  616.       fstatus  : integer;
  617.  
  618.     BEGIN (* blockdev *)
  619.     IF qfstatus(f, fstatus) THEN
  620.       blockdev := ((fstatus AND chrdev = 0))
  621.     ELSE blockdev := false;
  622.     END; (* blockdev *)
  623.  
  624.   (* 1---------------1 *)
  625.  
  626.   FUNCTION stdin(VAR f : text) : boolean;
  627.   (* Is the file attached to the console device *)
  628.  
  629.     VAR
  630.       fstatus  : integer;
  631.  
  632.     BEGIN (* stdin *)
  633.     IF qfstatus(f, fstatus) THEN
  634.       stdin := ((fstatus AND chrdev <> 0)) AND
  635.                ((fstatus AND istdin) <> 0)
  636.     ELSE stdin := false;
  637.     END; (* stdin *)
  638.  
  639.   (* 1---------------1 *)
  640.  
  641.   FUNCTION stdout(VAR f : text) : boolean;
  642.  
  643.     VAR
  644.       fstatus  : integer;
  645.  
  646.     BEGIN (* stdout *)
  647.     IF qfstatus(f, fstatus) THEN
  648.       stdout := ((fstatus AND chrdev <> 0)) AND
  649.                 ((fstatus AND istdout) <> 0)
  650.     ELSE stdout := false;
  651.     END; (* stdout *)
  652.  
  653.   (* 1---------------1 *)
  654.  
  655.   FUNCTION stderr(VAR f : text) : boolean;
  656.  
  657.     VAR
  658.       fstatus  : integer;
  659.  
  660.     BEGIN (* stderr *)
  661.     IF qfstatus(f, fstatus) THEN
  662.       stderr := ((fstatus AND chrdev <> 0)) AND
  663.                 ((fstatus AND istderr) <> 0)
  664.     ELSE stderr := false;
  665.     END; (* stderr *)
  666.  
  667.   (* 1---------------1 *)
  668.  
  669.   BEGIN (* txtfiles initialization routine *)
  670.   saverrproc := exitproc; exitproc := addr(txterrproc);
  671.   IF version(false) <> ver THEN halt;
  672.   END. (* txtfiles *)
  673. ╝